perm filename PLTSRT.F4[MSS,LCS] blob sn#141320 filedate 1975-01-21 generic text, type T, neo UTF8
00010	C  SUBRS. RHORZ, SLUR, JUGGLE, (LOOP), PLTSRT, LINES, RDRAW
00020	
06000		FUNCTION RHORZ(R)
06100		RHORZ=R*5.96-596.
06200		END
06300	
06400	
06500		SUBROUTINE SLUR
06600		IMPLICIT INTEGER(A-Q,T-Z)
06610		DIMENSION SLURX(72)
06700		REAL CENTR,PWDS
06710		COMMON /XRN/RN(4000) /PLTR/PLT,RHT,RDIS
06900		COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
06950		1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
06962		1 J5,J6,J7,J8,J9,J10,J11,JQ(9)
07000		COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(-3/4),RSTJ3
07010		COMMON/ALF/INP,SLURY(72) 
07400		DATA RZZ/2.8/
07500	C  DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8	
07600	
07805		IF(JA.NE.12)GO TO 2
07810		RA=5.96*RSTJ3*R5
07815		L=3
07817		J8=J8*RDIS
07820		IF(J7.LE.J6)J7=J7+360
07822		KQ=6
07823		IF(PLT)KQ=1
07825	10	DO 3 K=J6,J7,KQ
07830		R=K
07835		CALL LINES(R2+RA*SIND(R),CENTR+RA*COSD(R),L)
07840	3	L=2
07841		J8=J8-1
07842		IF(J8)RETURN
07843		RA=RA+1/RDIS
07844		GO TO 10
07845	CJA=12  DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
07850		RETURN
07880	
07900	2	J10=1
07901		J4=-1
07902		KQ=3
07903		TWICE=-1
07904	C  -1 FOR DISPLAY, USES ONLY 1/3 OF SEGMENTS
07905		IF(PLT.GE.0.OR.J8.GT.0)GO TO 21
07910		TWICE=0
07912		KQ=1
07915		RWID=.2
07920		IF(RHT.LT.2)GO TO 21
07925		TWICE=1
07927		RWID=.14
07928	C  IF SIZE IS GT.2 3 SLURS ARE DRAWN
07930	21	RST7=RSTJ3*7.
07960		RQQ=R5-R4
08000		IF(R6.GT.1000)CALL RNOTE(R6)
08010		GO TO (5,6,7),J8+4
08015		GO TO 4
08020	5	R=32
08025	C AFTER DOTTED NOTE
08030		GO TO 8
08040	6	R=22
08045	C BETWEEN NOTES
08050	8	RX=-1.3
08060		GO TO 9
08070	7	R=7
08080		RX=RSTJ3
08090	9	CALL RJBX(R)
08100		R6=R6+RX
08250	4	RXX=RHORZ(R6)-R2
08260		RTILT=RQQ*RST7
08270	80	RX=SQRT(RXX**2+RTILT**2)
08280	1	R=CENTR
08300		IF(J8.GT.0)GO TO 180
08400	C  FOR BRACKETS
08410		RB=RX/71.
08500		DO 81 K=0,71
08600	81	SLURX(K+1)=RB*(K)+R2
08700		RA=R7*RST7
08775	41	IF(R9.EQ.0)R9=RZZ
08800		R=R+RA
08900		L=0
09000		DO 40 K=36,1,-1
09100		L=L+1
09200		RW=R-RA*(K/36.)**R9
09300		SLURY(L)=RW
09400	40	SLURY(73-L)=RW
09600		L=72
09700	
09800	89	IF(RTILT.EQ.0)GO TO 87
09900	CC	R=RTILT*RF
10000		RW=ATAN2(RTILT,RXX)
10100		RA=SIN(RW)
10200		RB=COS(RW)
10300		RZ=SLURX(1)
10400		RW=SLURY(1)
10500		DO 84 K=1,L
10600		SLURX(K)=SLURX(K)-RZ
10700	84	SLURY(K)=SLURY(K)-RW
10800		DO 83 K=1,L
10900		R=SLURX(K)
11000		SLURX(K)=RB*R-RA*SLURY(K)+RZ
11100	83	SLURY(K)=RB*SLURY(K)+RA*R+RW
11200	
11300	87	IF(J4)CALL LINES(SLURX(J10),SLURY(J10),3)
11310		J5=KQ
11320		J6=J10
11330		J7=L
11340		IF(J4.NE.0)GO TO 22
11350		CALL EXCH(J6,J7)
11360		J5=-1
11400	22	DO 88 K=J6,J7,J5
11500	88	CALL LINES(SLURX(K),SLURY(K),2)
11505		IF(J5.GT.1)CALL LINES(SLURX(72),SLURY(72),2)
11507	C  DISPLAY END POINT OF SLUR
11510		IF(TWICE)RETURN
11520		TWICE=TWICE-1
11522		IF(J8.GT.0)GO TO 182
11525		J4=J4+1
11530		R7=R7+RWID
11535	C  RWID=WIDTH OF SLUR -- SEE DATA
11540		GO TO 1
11700	180	RW=R+R7*RST7
11710		TWICE=-1
11750		KQ=1
11800		RX=RX+R2
11900	CC	RA=(R5-R4)*RST7
11910		IF(J9.EQ.0)GO TO 181
11911		RZ=RTILT/(RX-R2)
11912		TWICE=2
11913	CC	RZ=RX-R2
11914		RXX=RX
11916		RWID=(R2+RXX)/2.
11992	182	IF(TWICE.EQ.1)GO TO 183
11993	C  DOES LEFT SIDE FIRST.
11994		IF(TWICE.EQ.0)GO TO 184
11995	C LAST IS NUMBER.
11996		J8=2
11999		RC=RSTJ3*13.
12000		RX=RWID-RC
12010		RWW=RTILT
12012	185	RTILT=RZ*(RX-R2)
12020	
12030	C  PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
12040	
12050		GO TO 181
12060	183	J8=3
12062		RX=RXX
12066		RTILT=RWW
12068		RXX=R2
12070		R2=RWID+RC
12082		RXX=RZ*(R2-RXX)
12100		R=R+RXX
12110		RW=RW+RXX
12120		GO TO 185
12150	
12180	181	SLURX(1)=R2
12190		SLURY(1)=R
12200		SLURX(2)=R2
12300		SLURY(2)=RW
12400		SLURX(3)=RX
12500		SLURY(3)=RW+RTILT
12600		SLURX(4)=RX
12700		SLURY(4)=R+RTILT
12800		L=4
12900		IF(J8.EQ.2)L=3
13000		IF(J8.EQ.3)J10=2
13010	CC	TWICE=-1
13100		GO TO 87
13110	184	J2=RWID
13120	C  PUT IN VERT. POS. WHEN SLOPE!
13130		R4=RQQ/2.+R4+R7-1.
13135		R5=1.
13137		R7=0
13140		CALL MAKNUM(R9)
13200		END
13300	C  8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
13400	C        FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
13500	C  P9=NUM IN BRACKET(IF NON-ZERO)
13600	
13700	C********  JUGGLER  ********
13800		SUBROUTINE JUGGLE
13900		IMPLICIT INTEGER(A-Z)
14000		REAL PWDS,RN
14100		COMMON /DL/X22,SAVER,NAME /XRN/RN(4000)
14200	      COMMON/PTR/PWDS(250),ITEM,L,I,IX/DPY/ST(4000),WDS(250),MEDIT,IGO
14300	
14400		ITEM=ITEM-1
14500		JX=RN(MEDIT)+3
14600	C  WD CNT OF OLD ITEM
14700	C  I-IX IS WD CNT OF NEW ITEM
14800		JY=IX
14900		Z=I-IX-JX
15000	C  SPACE CHANGE
15100		IF(Z)2751,172,751
15200	751	CALL LOOP(I-1,MEDIT+JX,-1,Z,0,RN)
15300		JY=IX+Z
15400		GO TO 172
15500	
15600	2751	CALL LOOP(MEDIT+JX+Z,IX+Z-1,1,0,-Z,RN)
15700	
15800	172	J=RN(JY)+2
15900		CALL LOOP(0,J,1,MEDIT,JY,RN)
16000		I=IX+Z
16100	
16200	1751	X=ITEM+1
16300		JX=WDS(X22+1)-WDS(X22)
16400		J=WDS(X+1)-WDS(X)
16500		Y=J-JX
16600		JX=WDS(X)+Y+1
16700		IF(Y)2851,182,282
16800	282	CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
16900		GO TO 182
17000	
17100	2851	CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
17200		JX=WDS(X)+1
17300	
17400	182	CALL LOOP(1,J,1,WDS(X22)+1,JX,ST)
17500		DO 183 K=X22+1,X
17600		PWDS(K)=PWDS(K)+Z
17700	183	WDS(K)=WDS(K)+Y
17800		ST(2)=WDS(X)
17900		X22=0
18000		END
18100	
18200	
18300		SUBROUTINE LOOP(I,J,K,L,M,N)
18400		DIMENSION N(1)
18420		MM=M-L
18500		DO 1 NN=I+L,J+L,K
18600	1	N(NN)=N(NN+MM)
18700		END
19300	
19400	
19500		SUBROUTINE PLTSRT(M)
19600	C  SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING. 
19700		IMPLICIT INTEGER(S-Z)
19800		COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
19940		COMMON/DPY/Q(3000),P(1000),WDS(250),MEDIT,IGO
19970	C  Q AND P OCCUPY DPY BUFFER.  Q IS FOR OVERFLOW OF RN.
20000		DO 4 K=1,ITEM
20100		L=PWDS(K)
20150		A=RN(L+2)
20200		P(K)=A+1000*RN(L+3)
20250	4	IF(A.LT.0.OR.RN(L+1).EQ.16.)P(K)=-10000
20275	C  PLOTS ALL NEG. HORIZ. POSITIONS AND WORDS(CODE 16) FIRST.
20300		M=I
20320		IF(I.LT.1500)I=1500
20340		Y=I
20360		I=I+M-1
20380		M=Y
20400	C  M IS IN MAIN PROG., LEAVES 1500 WDS IN RN FOR "NOIR" DATA.
20500	2	A=P(1)
20600		L=1
20700		DO 1 K=1,ITEM
20800		IF(A.LE.P(K))GO TO 1
20900		A=P(K)
21000		L=K
21100	1	CONTINUE
21200		IF(A.EQ.10000.)RETURN
21300	C  ALL ITEMS HAVE NOW BEEN SHUFFLED
21400		V=PWDS(L)
21500		P(L)=10000
21600		L=RN(V)+2
21700		CALL LOOP(0,L,1,Y,V,RN)
21800		Y=Y+L+1
21900		GO TO 2
22000		END
22100	
22200	
22300	
22400		SUBROUTINE BOX(I,R,STFF)
22500	      COMMON/SIZ/RSZ,JCEN,KCEN /XRN/RN(4000) /STF/RSTFAC(-3/4),RSTJ3
22925		DIMENSION STFF(1),N(100)
22962		EQUIVALENCE (N,RN(2901))
23000		IF(I)GO TO 4
23100		K=R
23200		K=(STFF(K+4)+AMOD(RN(I+4),100.0)*7.*RSTFAC(K)
23300		1 -40.0)*RSZ-KCEN
23350	C  ↑↑↑↑ WAS -60.0 10/74
23400	C  AMOD IS FOR MINI NOTES AND CLEFS
23500		L=RHORZ(RN(I+2))*RSZ-JCEN
23600		IF(IABS(L).GT.550)L=511
23700		IF(IABS(K).GT.550)K=511
23800	CC1	CALL ALINE(L,K,L+50,K)
23900	CC	CALL RVECT(0,100)
24000	CC	CALL RVECT(-50,0)
24100	CC	CALL RVECT(0,-100)
24200	CC	L=L+25
24300	CC2	CALL ALINE(L,K-25,L,K+125)
24450	CC3	CALL DPYOUT(1)
24460		CALL SETCUR(L,K,0)
24500		RETURN
24600	4	IF(I.LT.-1)GO TO 5
24700		CALL DPYSET(3,N,100)
24800		CALL DPYBRT(3)
24900	5	L=RHORZ(R)*RSZ-JCEN
25000		IF(IABS(L).GT.550)GO TO 6
25050	C DOESN'T TRY TO DRAW LINE OFF SCREEN
25100		CALL SETPOG(3)
25200		CALL ALINE(L,-511,L,511)
25300		CALL DPYOUT(3)
25400	6	CALL SETPOG(1)
25600		END
25700	
25800		SUBROUTINE LINES(A,B,L)
25850		COMMON/DST/BB,CC
25900		COMMON /SIZ/RSZ,JCEN,KCEN /FL/IC,NZ,NX,RZ,XGP
26000		COMMON/DL/IXRX,SAVER,AA /PLTR/IPLT,RHT,DIS
26100		COMMON R2,JA,CENTR,JB,RJQ(20),JQ(20)
26200		COMMON/DPY/JJ(4000),WDS(250),MEDIT,IGO
26400		EQUIVALENCE (ITOP,JJ(3999)),(IBOT,JJ(4000))
26402		1,(JJ2,JJ(2))
26500		DATA BB/.008/,CC/3.5/
26600	C  SET XGP TO 1200.0 FOR MARGIN IN XEROX COPIES
26650		GO TO 23
26700	22	IF(JQ(1).NE.0)GO TO 23
26750		IF(CC.EQ.1000)GO TO 23
26775	C  ABOVE TO SKIP DISTORTION ON COMMAND
26800	C  CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
27000	C  USE THIS IN DDT TO DISTORT ITEMS.  CC MUST BE > DD
27100		B=B*(CC-BB*ABS(A))
27150	C  CC IS HGT FACTOR.
27200	23	IF(IPLT)GO TO 2
27300		M=A*RSZ
27400		N=B*RSZ
27500		IF(RSZ.LE.0.8571)GO TO 3
27600	C NEXT FOR DISPLAY MAGNIFICATION
27700		M=M-JCEN
27800		N=N-KCEN
27900		IF(JA.NE.10)GO TO 5
28000	C NEXT INSURES DISPLAY OF STAFF LINES
28100		IF(M.GT.511)M=511
28200		IF(M.LT.-511)M=-511
28400	5	IF(IABS(M).LT.512.AND.IABS(N).LT.512)GO TO 4
28500	C  NOW DRAWS INVISIBLE VECT. IF IT GOES OFF THE SCREEN.
28600		KZ=-1
28700		RETURN
28800	4	IF(KZ.EQ.0)GO TO 6
28900		KZ=0
29000		GO TO 1
29050	3	IF(JA.EQ.44)GO TO 6
29075	C JA=44=BAR LINES - THEY DON'T FIGURE IN MAX. HGT.
29100		K=B
29200		IF(K.GT.ITOP)ITOP=B
29300		IF(K.LT.IBOT)IBOT=B
29302	6	IF(JJ2.GT.3990)RETURN
29400		IF(L.EQ.3)GO TO 1
29500		CALL AVECT(M,N)
29600		RETURN
29700	1	CALL AIVECT(M,N)
29800		RETURN
29900	2	IF(IPLT.EQ.-2)RETURN
30300	C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
30400	CC	IF(B)BX=-BX
30500	C  AX AND BX ARE FOR ROUND-OFF
30600	CC	IF(IXRX.EQ.0)GO TO 9
30610	CC	M=ROFF(RXGP-B*RHT)
30620	CC	N=ROFF(XGP+A*DIS)
30900	CC	GO TO 8
31110	9	M=ROFF(A*DIS)
31120		N=ROFF(B*RHT)
31200	8	CALL PLOT(M,N,L)
31400		END
31540	
31600		SUBROUTINE RDRAW(I,S,XY,X,R2,CENTR,RMINI)
31700	C   TO X,Y INTO ONE WORD
31800		DIMENSION XY(1)
31900		DO 2 K=I,IFIX(S)
32000		L=2
32100		Y=XY(K)
32200		IF(Y.LT.1000.)GO TO 3
32300		L=3
32400		Y=Y-1000.
32500	C   >1000 = INVIS. LINE
32600	3	M=Y
32700		Y=(Y-M)*1000.
32800		IF(Y.GT.100.)Y=100-Y
32900	C   Y NUMBERS .GT.100 ARE NEG.
33000		B=Y*X+CENTR
33100		IF(M.GT.60)M=100-M
33200		A=M*RMINI+R2
33300	2	CALL LINES(A,B,L)
33500		END